home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
set.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
3KB
|
126 lines
/* ******************************************************************** */
/* set.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* support for "set" */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, May 1989
*
* Had to add a new function to get it to work on anoymous functions
* (16/11/89) KJP
*/
#include "defs.h"
#include "structs.h"
#include "funcalls.h"
#include "error.h"
#include "global.h"
#include "class.h"
#include "ngenerics.h"
/* Global table of relations... */
LispObject set_lookup_table;
/* accepts a function or a name of a function */
EUFUN_1( Fn_setter, func)
{
LispObject setter = func,ans;
int bool;
while (TRUE) {
STACK_TMP(setter);
bool = is_function(setter);
UNSTACK_TMP(setter);
if (bool || is_generic(setter)) break;
setter =
CallError(stacktop,
"setter: non-function supplied",ARG_0(stackbase),CONTINUABLE);
}
EUCALLSET_2(ans, Fn_tref,set_lookup_table,setter);
if (null(ans))
signal_message(stacktop, NO_UPDATE_FUNCTION,
"setter: no updator for function",ARG_0(stackbase));
return(ans);
}
EUFUN_CLOSE
/* associate the updator with the function func: both are ids */
void set_associate(LispObject *stacktop, LispObject func,LispObject updator)
{
EUCALL_3(tref_updator, set_lookup_table,
func->SYMBOL.lvalue,updator->SYMBOL.lvalue);
}
/* as above for function objects */
void set_anon_associate(LispObject *stacktop, LispObject get,LispObject set)
{
EUCALL_3(tref_updator,set_lookup_table,get,set);
}
/* make the updator of the function func be "updator" */
EUFUN_2( set_updator, func, updator)
{
LispObject old;
int bool;
while (TRUE) {
bool = is_function(func);
func = ARG_0(stackbase);
if (bool || is_generic(func)) break;
func
= CallError(stacktop,
"(setter setter): can't associate setter with non-function",
ARG_0(stackbase),CONTINUABLE);
ARG_0(stackbase) = func;
}
updator = ARG_1(stackbase);
while (TRUE) {
bool = is_function(updator);
updator = ARG_1(stackbase);
if ( bool || is_generic(updator)) break;
updator
= CallError(stacktop,
"(setter setter): prospective associate not a function",
ARG_1(stackbase),CONTINUABLE);
ARG_1(stackbase) = updator;
}
func = ARG_0(stackbase);
ARG_0(stacktop) = set_lookup_table;
ARG_1(stacktop) = func;
if ((old = Fn_tref(stacktop)) != nil)
CallError(stacktop,
"(setter setter): a setter already exists",
ARG_0(stackbase),NONCONTINUABLE);
set_anon_associate(stacktop, ARG_0(stackbase),ARG_1(stackbase));
return ARG_1(stackbase); /* updator */
}
EUFUN_CLOSE
void initialise_set(LispObject *stacktop)
{
LispObject fun,upd;
set_lookup_table = (LispObject) allocate_table(stacktop, Fn_eq);
add_root(&set_lookup_table);
fun = make_module_function(stacktop,"setter",Fn_setter,1);
STACK_TMP(fun);
upd = make_module_function(stacktop,"(setter setter)",set_updator,2);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
}